home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / nrat4.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  20.8 KB  |  667 lines

  1. ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;;     The data in this file contains enhancments.                    ;;;;;
  4. ;;;                                                                    ;;;;;
  5. ;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
  6. ;;;     All rights reserved                                            ;;;;;
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;;     (c) Copyright 1982 Massachusetts Institute of Technology         ;;;
  9. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10.  
  11. (in-package "MAXIMA")
  12. (macsyma-module nrat4)
  13.  
  14. (DECLARE-TOP(GENPREFIX FQZ_)
  15.      (SPECIAL $RATSIMPEXPONS *EXP *EXP2 *RADSUBST *LOGLIST $RADSUBSTFLAG 
  16.           $RADEXPAND $LOGSIMP *V *VAR FR-FACTOR RADCANP RATSUBVL)
  17.      (*LEXPR $RATSIMP)
  18.      (FIXNUM NARGS))
  19.  
  20. (LOAD-MACSYMA-MACROS RZMAC RATMAC)
  21.  
  22. (DEFMVAR $RADSUBSTFLAG NIL
  23.   "RADSUBSTFLAG T makes RATSUBS call RADCAN when it appears useful")
  24.  
  25.  
  26. (DEFMFUN PDIS (X) ($RATDISREP (PDIS* X)))
  27.  
  28. (DEFUN PDIS* (X) `((MRAT SIMP ,VARLIST ,GENVAR) ,X . 1))
  29.  
  30. (DEFUN RDIS (X) ($RATDISREP (RDIS* X)))
  31.  
  32. (DEFUN RDIS* (X) `((MRAT SIMP ,VARLIST ,GENVAR) . ,X))
  33.  
  34. (DEFUN RFORM (X) (CDR (RATF X)))
  35.  
  36. (SETQ RADCANP NIL)
  37.  
  38. (DEFMFUN $RATCOEF NARGS
  39.   (COND ((= NARGS 3) (RATCOEFF (ARG 1) (ARG 2) (ARG 3)))
  40.     ((= NARGS 2) (RATCOEFF (ARG 1) (ARG 2) 1))
  41.     (T (WNA-ERR '$RATCOEFF))))  ; The spelling "RATCOEFF" is nicer.
  42.  
  43. (DEFMFUN RATCOEFF (A B C)
  44.   (LET* ((FORMFLAG ($RATP A))
  45.      (TAYLORFORM (AND FORMFLAG (MEMQ 'TRUNC (CDAR A)))))
  46.     (COND ((ZEROP1 B) (IMPROPER-ARG-ERR B '$RATCOEFF))
  47.       ((MBAGP A) (CONS (CAR A)
  48.                (MAPCAR #'(LAMBDA (A) (RATCOEFF A B C))
  49.                    (CDR A))))
  50.       ((AND TAYLORFORM (MNUMP C) (ASSOLIKE B (CADDDR (CDAR A))))
  51.        (PSCOEFF1 A B C))
  52.       ((AND TAYLORFORM (MEXPTP B) (MNUMP C) (MNUMP (CADDR B))
  53.         (ASSOLIKE (CADR B) (CADDDR (CDAR A))))
  54.        (PSCOEFF1 A (CADR B) (MUL2 C (CADDR B))))
  55.       ((AND TAYLORFORM (EQUAL C 0)) A)
  56.       (T (IF TAYLORFORM (SETQ A (RATDISREP A)))
  57.          (SETQ A (LET ($RATWTLVL)
  58.                (IF (EQUAL C 0)
  59.                (RATCOEF (MUL2* A B) B)
  60.                (RATCOEF A (IF (EQUAL C 1) B (LIST '(MEXPT) B C))))))
  61.          (IF (AND FORMFLAG (NOT TAYLORFORM))
  62.          (MINIMIZE-VARLIST A)
  63.          (RATDISREP A))))))
  64.  
  65. (DEFUN MINIMIZE-VARLIST (RATFUN)
  66.   (IF (NOT ($RATP RATFUN)) (SETQ RATFUN (RATF RATFUN)))
  67.   (MINVARLIST-MRAT (CADDR (CAR RATFUN)) (CADDDR (CAR RATFUN))
  68.            (CDR RATFUN)))
  69.  
  70. (DEFUN MINVARLIST-MRAT (VARS GENS RATFORM)
  71.   (LET ((NEWGENS (UNION* (LISTOVARS (CAR RATFORM))
  72.              (LISTOVARS (CDR RATFORM)))))
  73.     (DO ((LV VARS (CDR LV))
  74.      (LG GENS (CDR LG))
  75.      (NLV ())
  76.      (NLG ()))
  77.     ((NULL LG)
  78.      (CONS (LIST 'MRAT 'SIMP (NREVERSE NLV) (NREVERSE NLG))
  79.            RATFORM))
  80.       (COND ((MEMQ (CAR LG) NEWGENS)
  81.          (PUSH (CAR LG) NLG)
  82.          (PUSH (CAR LV) NLV))))))
  83.  
  84. (DEFUN RATCOEF (EXP VAR)
  85.   (PROG (VARLIST GENVAR $RATFAC $ALGEBRAIC $RATWTLVL BAS MINVAR)
  86.     (SETQ VAR (RATDISREP VAR))
  87.     (SETQ BAS (IF (AND (MEXPTP VAR) (MNUMP (CADDR VAR))) (CADR VAR) VAR))
  88.     (NEWVAR VAR)
  89.     (NEWVAR BAS)
  90.     (SETQ MINVAR (CAR VARLIST))
  91.     (NEWVAR EXP)
  92.     (SETQ EXP (CDR (RATREP* EXP)))
  93.     (SETQ VAR (CDR (RATREP* VAR)))
  94.     (SETQ BAS (CADR (RATREP* BAS)))
  95.     (IF (AND (ONEP1 (CDR EXP)) (ONEP1 (CDR VAR)) (PUREPROD (CAR VAR)))
  96.         (RETURN (PDIS* (PRODCOEF (CAR VAR) (CAR EXP)))))
  97.     (SETQ EXP (RATQUOTIENT EXP VAR))
  98.     (IF (NULL MINVAR) (RETURN (PDIS* (PRODCOEF (CDR EXP) (CAR EXP)))))
  99.     (SETQ MINVAR (CAADR (RATREP* MINVAR)))
  100. LOOP    (IF (OR (PCOEFP (CDR EXP)) (POINTERGP MINVAR (CADR EXP)))
  101.         (RETURN (RDIS* (CDR (RATDIVIDE EXP BAS)))))
  102.     (SETQ EXP (RATCOEF1 (CAR EXP) (CDR EXP)))
  103.     (GO LOOP)))
  104.  
  105. (DEFUN RATCOEF1 (NUM DEN)
  106.        (COND ((PCOEFP NUM) (RZERO))
  107.          ((EQ (CAR NUM) (CAR DEN)) (CAR (PDIVIDE NUM DEN)))
  108.          ((POINTERGP (CAR DEN) (CAR NUM)) (RZERO))
  109.          (T (RATCOEF1 (CONSTCOEF (CDR NUM)) DEN))))
  110.  
  111. (DEFUN CONSTCOEF (P)
  112.        (COND ((NULL P) 0)
  113.          ((ZEROP (CAR P)) (CADR P))
  114.          (T (CONSTCOEF (CDDR P)))))
  115.  
  116. (SETQ *RADSUBST NIL RATSUBVL T)            ;SUBST ON VARLIST
  117.  
  118. (DEFMFUN $RATSUBST (A B C)    ;NEEDS CODE FOR FAC. FORM 
  119.   (PROG (VARLIST NEWVARLIST DONTDISREPIT $RATFAC GENVAR)
  120.     ;;hard to maintain user ordering info.
  121.     (IF ($RATP C) (SETQ DONTDISREPIT T))
  122.     (WHEN (AND $RADSUBSTFLAG
  123.            (PROG2 (NEWVAR B) (ORMAPC #'MEXPTP VARLIST)))
  124.           (LET (($FACTORFLAG T) *EXP *EXP2 *RADSUBST)
  125.         (SETQ B (FULLRATSIMP B))
  126.         (SETQ C (FULLRATSIMP C))
  127.         (SETQ VARLIST NIL)
  128.         (FNEWVAR B)
  129.         (FNEWVAR C)
  130.         (SETQ *EXP (CDR (RATREP* B)))
  131.         (SETQ *EXP2 (CDR (RATREP* C)))
  132.      ;;    since *radsubst is t, both *exp and *exp2 will be radcan simplified
  133.         (SETQ *RADSUBST T)
  134.         (SPC0)
  135.         (SETQ B (RDIS *EXP) C (RDIS *EXP2))
  136.         (SETQ VARLIST NIL)))
  137.        (SETQ A ($RATDISREP A) B ($RATDISREP B) C ($RATDISREP C))
  138.        (COND ((INTEGERP B) (SETQ C (RATF (MAXIMA-SUBSTITUTE A B C)))
  139.                (RETURN (COND (DONTDISREPIT C) (T ($RATDISREP C))))))
  140.        (NEWVAR C)
  141.        (SETQ
  142.     NEWVARLIST
  143.     (IF RATSUBVL
  144.         (MAPCAR
  145.          #'(LAMBDA (Z)
  146.          (COND ((ATOM Z) Z)
  147.                (T (RESIMPLIFY
  148.                (CONS (CAR Z)
  149.                  (MAPCAR #'(LAMBDA (ZZ)
  150.                          (COND ((ALIKE1 ZZ B) A)
  151.                            ((ATOM ZZ) ZZ)
  152.                            (T ($RATDISREP
  153.                                ($RATSUBST A B ZZ)))))
  154.                      (CDR Z)))))))
  155.          VARLIST)
  156.         VARLIST))
  157.        (NEWVAR A) (NEWVAR B)
  158.        (SETQ NEWVARLIST (REVERSE (PAIROFF (REVERSE VARLIST)
  159.                       (REVERSE NEWVARLIST))))
  160.        (SETQ A (CDR (RATREP* A)))
  161.        (SETQ B (CDR (RATREP* B)))
  162.        (SETQ C (CDR (RATREP* C)))
  163.        (WHEN (PMINUSP (CAR B))
  164.          (SETQ B (RATMINUS B))
  165.          (SETQ A (RATMINUS A)))
  166.        (WHEN (AND (EQN 1 (CAR B)) (NOT (EQN 1 (CDR B)))(NOT (EQN (CAR A) 0)))
  167.          (SETQ A (RATINVERT A))
  168.          (SETQ B (RATINVERT B)))
  169.        (COND ((NOT (EQN 1 (CDR B)))
  170.           (SETQ A (RATTIMES A (CONS (CDR B) 1) T))
  171.           (SETQ B (CONS (CAR B) 1))))
  172.        (SETQ C
  173.     (COND ((zl-MEMBER (CAR B) '(0 1))
  174.            (RATF (MAXIMA-SUBSTITUTE (RDIS A) B (RDIS C))))
  175.           (T (CONS (LIST 'MRAT 'SIMP VARLIST GENVAR)
  176.                (IF (EQN (CDR A) 1)
  177.                (RATREDUCE (EVERYSUBST0 (CAR A) (CAR B) (CAR C))
  178.                       (EVERYSUBST0 (CAR A) (CAR B) (CDR C)))
  179.                (ALLSUBST00 A B C))))))
  180.        (UNLESS (ALIKE NEWVARLIST VARLIST)
  181.            (SETQ VARLIST NEWVARLIST
  182.              C (RDIS (CDR C))
  183.              VARLIST NIL
  184.              C (RATF C)))
  185.        (RETURN (COND (DONTDISREPIT C) (T ($RATDISREP C))))))
  186.  
  187. (DEFUN XPTIMES (X Y) (IF $RATWTLVL (WTPTIMES X Y 0) (PTIMES X Y)))
  188.  
  189. (DEFUN ALLSUBST00 (A B C)
  190.       (COND ((EQUAL A B) C)
  191.          (T (RATQUOTIENT (EVERYSUBST00 A (CAR B) (CAR C))
  192.                  (EVERYSUBST00 A (CAR B) (CDR C))))))
  193.  
  194. (DEFUN EVERYSUBST00 (X I Z)
  195.   (SLOOP WITH ANS = (RZERO)
  196.     FOR (EXP COEF) ON (EVERYSUBST I Z *ALPHA) BY 'PT-RED
  197.     DO (SETQ ANS (RATPLUS ANS (RATTIMES (CONS COEF 1) (RATEXPT X EXP) T)))
  198.     FINALLY (RETURN ANS)))
  199.  
  200. (DEFUN EVERYSUBST0 (X I Z)
  201.   (SLOOP WITH ANS = (PZERO)
  202.     FOR (EXP COEF) ON (EVERYSUBST I Z *ALPHA) BY 'PT-RED
  203.     DO (SETQ ANS (PPLUS ANS (XPTIMES COEF (PEXPT X EXP))))
  204.     FINALLY (RETURN ANS)))
  205.  
  206. (DEFUN EVERYSUBST1 (A B MAXPOW)
  207.   (SLOOP FOR (EXP COEF) ON (P-TERMS B) BY 'PT-RED
  208.     FOR PART = (EVERYSUBST A COEF MAXPOW)
  209.     NCONC (IF (= 0 EXP) PART
  210.           (EVERYSUBST2 PART (MAKE-POLY (P-VAR B) EXP 1)))))
  211.  
  212. (DEFUN EVERYSUBST2 (L H)
  213.   (DO ((PTR L (CDDR PTR)))
  214.       ((NULL PTR) L)
  215.     (SETF (CADR PTR) (PTIMES H (CADR PTR)))))
  216.  
  217.  
  218. (DEFUN PAIROFF (L M)
  219.   (COND ((NULL M) L) (T (CONS (CAR M) (PAIROFF (CDR L) (CDR M))))))
  220.  
  221. ;(DEFUN PAIROFF (L M)
  222. ;  ;(COND ((NULL M) L) (T (CONS (CAR M) (PAIROFF (CDR L) (CDR M)))))
  223. ;  (let ((ans nil))
  224. ;    (dolist (x m (nreconc ans l))
  225. ;      (push x ans) (setq l (cdr l)))))
  226.  
  227. (DEFUN EVERYSUBST (A B MAXPOW)
  228.   (COND ((PCOEFP A)
  229.      (COND ((EQN A 1) (LIST MAXPOW B))
  230.            ((PCOEFP B)
  231.         (LIST (SETQ MAXPOW
  232.                 (DO ((B B (QUOTIENT B A))
  233.                  (ANS 0 (f1+ ANS)))
  234.                 ((OR (GREATERP (ABS A) (ABS B))
  235.                      (EQN MAXPOW ANS))
  236.                   ANS)))
  237.               (QUOTIENT B (SETQ MAXPOW (EXPT A MAXPOW)))
  238.               0
  239.               (REMAINDER B MAXPOW)))
  240.            (T (EVERYSUBST1 A B MAXPOW))))
  241.     ((OR (PCOEFP B) (POINTERGP (CAR A) (CAR B))) (LIST 0 B))
  242.     ((EQ (CAR A) (CAR B))
  243.      (COND ((NULL (CDDDR A)) (EVERYPTERMS B (CADDR A) (CADR A) MAXPOW))
  244.            (T (SUBSTFORSUM A B MAXPOW))))
  245.     (T (EVERYSUBST1 A B MAXPOW))))
  246.  
  247. (DEFUN EVERYPTERMS (X P N MAXPOW)
  248.   (IF (LESSP (CADR X) N) (LIST 0 X)
  249.       (PROG (K ANS Q PART)
  250.         (SETQ K (CAR X))
  251.         (SETQ X (CDR X))
  252.        L    (SETQ Q (MIN MAXPOW (QUOTIENT (CAR X) N)))
  253.        M    (COND ((EQN Q 0)
  254.            (RETURN (COND ((NULL X) ANS)
  255.                  (T (CONS 0
  256.                       (CONS (PSIMP K X) ANS)))))))
  257.             (SETQ PART (EVERYSUBST P (CADR X) Q))
  258.         (SETQ ANS (NCONC (EVERYPTERMS1 PART K N (CAR X)) ANS))
  259.         (SETQ X (CDDR X))
  260.         (COND ((NULL X) (SETQ Q 0) (GO M)))
  261.         (GO L))))
  262.  
  263. (DEFUN EVERYPTERMS1 (L K N J)
  264.   (DO ((PTR L (CDDR PTR)))
  265.       ((NULL PTR) L)
  266.     (SETF (CADR PTR)
  267.       (PTIMES (PSIMP K (LIST (f- J (f* N (CAR PTR))) 1))
  268.           (CADR PTR)))))
  269.  
  270. (DEFUN SUBSTFORSUM (A B MAXPOW)
  271.   (DO ((POW 0 (ADD1 POW))
  272.        (QUOT) (zl-REM) (ANS))
  273.       ((NOT (LESSP POW MAXPOW)) (LIST* MAXPOW B ANS))
  274.     (DESETQ (QUOT zl-REM) (PDIVIDE B A))
  275.     (UNLESS (AND (EQN (CDR QUOT) 1)
  276.          (NOT (PZEROP (CAR QUOT)))
  277.          (EQN (CDR zl-REM) 1))
  278.         (RETURN (CONS POW (CONS B ANS))))
  279.     (UNLESS (PZEROP (CAR zl-REM))
  280.         (SETQ ANS (CONS POW (CONS (CAR zl-REM) ANS))))
  281.     (SETQ B (CAR QUOT))))
  282.  
  283. (DEFUN PRODCOEF (A B)
  284.        (COND ((PCOEFP A)
  285.           (COND ((PCOEFP B) (QUOTIENT B A)) (T (PRODCOEF1 A B))))
  286.          ((PCOEFP B) (PZERO))
  287.          ((POINTERGP (CAR A) (CAR B)) (PZERO))
  288.          ((EQ (CAR A) (CAR B))
  289.           (COND ((NULL (CDDDR A))
  290.              (PRODCOEF (CADDR A) (PTERM (CDR B) (CADR A))))
  291.             (T (SUMCOEF A B))))
  292.          (T (PRODCOEF1 A B))))
  293.  
  294. (DEFUN SUMCOEF (A B)
  295.   (DESETQ (A B) (PDIVIDE B A))
  296.   (IF (AND (EQUAL (CDR A) 1) (EQUAL (CDR B) 1))
  297.       (CAR A)
  298.       (PZERO)))
  299.  
  300. (DEFUN PRODCOEF1 (A B)
  301.   (SLOOP WITH ANS = (PZERO)
  302.     FOR (BEXP BCOEF) ON (P-TERMS B) BY 'PT-RED
  303.     FOR PART = (PRODCOEF A BCOEF)
  304.     UNLESS (PZEROP PART)
  305.     DO (SETQ ANS (PPLUS ANS (PSIMP (P-VAR B) (LIST BEXP PART))))
  306.     FINALLY (RETURN ANS)))
  307.  
  308. (DEFUN PUREPROD (X)
  309.        (OR (ATOM X)
  310.        (AND (NOT (ATOM (CDR X)))
  311.         (NULL (CDDDR X))
  312.         (PUREPROD (CADDR X)))))
  313.  
  314. (DEFMFUN $BOTHCOEF (R VAR) 
  315.        (PROG (*VAR H VARLIST GENVAR $RATFAC)
  316.          (UNLESS ($RATP R)
  317.              (RETURN `((MLIST)
  318.                    ,(SETQ H (COEFF R VAR 1.))
  319.                    ((MPLUS) ,R ((MTIMES) -1 ,H ,VAR)))))
  320.          (NEWVAR VAR)
  321.          (SETQ H (AND VARLIST (CAR VARLIST)))
  322.          (NEWVAR R)
  323.          (SETQ VAR (CDR (RATREP* VAR)))
  324.          (SETQ R (CDR (RATREP* R)))
  325.          (AND H (SETQ H (CAADR (RATREP* H))))
  326.          (COND ((AND H (OR (PCOEFP (CDR R)) (POINTERGP H (CADR R)))
  327.              (EQUAL 1 (CDR VAR)))
  328.             (SETQ VAR (BOTHPRODCOEF (CAR VAR) (CAR R)))
  329.             (RETURN (LIST '(MLIST)
  330.                   (RDIS* (RATREDUCE (CAR VAR) (CDR R)))
  331.                   (RDIS* (RATREDUCE (CDR VAR) (CDR R))))))
  332.            (T (MERROR "Bad arguments to BOTHCOEFF")))))
  333.      
  334. ;COEFF OF A IN B
  335.  
  336. (DEFUN BOTHPRODCOEF (A B) 
  337.   (LET ((C (PRODCOEF A B)))
  338.     (IF (PZEROP C) (CONS (PZERO) B) (CONS C (PDIFFERENCE B (PTIMES C A))))))
  339.  
  340. (DEFVAR ARGSFREEOFP NIL)
  341.  
  342. (DEFMFUN ARGSFREEOF (VAR E)
  343.   (LET ((ARGSFREEOFP T)) (FREEOF VAR E)))
  344.  
  345. ;;; This is a version of freeof for a list first argument
  346. (defmfun $LFREEOF (l e) "FREEOF for a list first argument"
  347.    (unless ($listp l) (merror "First argument must be a list"))
  348.    (let ((exp ($TOTALDISREP e)))
  349.       (dolist (var (margs l) T)
  350.          (unless (freeof ($TOTALDISREP var) exp) (return nil)))))
  351.  
  352. (DEFMFUN $FREEOF NARGS
  353.   (PROG (L E) 
  354.     (SETQ L (MAPCAR #'$TOTALDISREP (NREVERSE (LISTIFY NARGS)))
  355.           E (CAR L))
  356.    LOOP (OR (SETQ L (CDR L)) (RETURN T))
  357.     (IF (FREEOF (GETOPR (CAR L)) E) (GO LOOP))
  358.     (RETURN NIL)))
  359.  
  360. ;(DEFMFUN FREEOF (VAR E) 
  361. ;  (COND ((ALIKE1 VAR E) NIL)
  362. ;    ((ATOM E) T)
  363. ;    ((AND (OR (MEMQ (CAAR E) '(%PRODUCT %SUM %LAPLACE))
  364. ;          (AND (EQ (CAAR E) '%INTEGRATE) (CDDDR E))
  365. ;          (AND (EQ (CAAR E) '%LIMIT) (CDDR E)))
  366. ;          (ALIKE1 VAR (CADDR E)))
  367. ;     (FREEOFL VAR (CDDDR E)))
  368. ;    ((EQ (CAAR E) '%AT)
  369. ;     (COND ((NOT (FREEOFL VAR (HAND-SIDE (CADDR E) 'R))) NIL)
  370. ;           ((NOT (FREEOFL VAR (HAND-SIDE (CADDR E) 'L))) T)
  371. ;           (T (FREEOF VAR (CADR E)))))
  372. ;    (ARGSFREEOFP (FREEOFL VAR (MARGS E)))
  373. ;    (T (AND (FREEOF VAR (CAAR E)) (FREEOFL VAR (CDR E))))))
  374. ;Update from F302 --gsb
  375. (DEFUN FREEOF (VAR E) 
  376.   (COND ((ALIKE1 VAR E) NIL)
  377.     ((ATOM E) T)
  378.     ((AND (NOT ARGSFREEOFP) (ALIKE1 VAR (CAAR E))) NIL)
  379.     ((AND (OR (MEMQ (CAAR E) '(%PRODUCT %SUM %LAPLACE))
  380.           (AND (EQ (CAAR E) '%INTEGRATE) (CDDDR E))
  381.           (AND (EQ (CAAR E) '%LIMIT) (CDDR E)))
  382.           (ALIKE1 VAR (CADDR E)))
  383.      (FREEOFL VAR (CDDDR E)))
  384.     ((EQ (CAAR E) '%AT)
  385.      (COND ((NOT (FREEOFL VAR (HAND-SIDE (CADDR E) 'R))) NIL)
  386.            ((NOT (FREEOFL VAR (HAND-SIDE (CADDR E) 'L))) T)
  387.            (T (FREEOF VAR (CADR E)))))
  388.     ((AND (EQ (CAAR E) 'LAMBDA) (MEMQ VAR (CDADR E))) T)
  389.     (ARGSFREEOFP (FREEOFL VAR (MARGS E)))
  390.     (T (FREEOFL VAR (CDR E)))))
  391.  
  392. (DEFUN FREEOFL (VAR L) (SLOOP FOR X IN L ALWAYS (FREEOF VAR X)))
  393.  
  394. (DEFMFUN HAND-SIDE (E FLAG)
  395.   (SETQ E (IF (EQ (CAAR E) 'MEQUAL) (NCONS E) (CDR E)))
  396.   (MAPCAR #'(LAMBDA (U) (IF (EQ FLAG 'L) (CADR U) (CADDR U))) E))
  397.  
  398. (COMMENT Subtitle RADCAN)
  399.  
  400. (DEFMFUN $RADCAN (EXP)
  401.        (COND ((MBAGP EXP) (CONS (CAR EXP) (MAPCAR '$RADCAN (CDR EXP))))
  402.          (T (LET (($RATSIMPEXPONS T))
  403.              (SIMPLIFY (LET (($EXPOP 0) ($EXPON 0))
  404.                     (RADCAN1 (FR1 EXP NIL))))))))
  405.  
  406. (DEFUN RADCAN1 (*EXP)
  407.        (COND ((ATOM *EXP) *EXP)
  408.          (T (LET (($FACTORFLAG T) VARLIST GENVAR $RATFAC $NOREPEAT
  409.               ($GCD (OR $GCD (CAR *GCDL*)))
  410.               (RADCANP T))
  411.              (NEWVAR *EXP)
  412.              (SETQ *EXP (CDR (RATREP* *EXP)))
  413.              (SETQ VARLIST
  414.                (MAPCAR
  415.                 #'(LAMBDA (X) (COND
  416.                      ((ATOM X) X)
  417.                      (T (CONS (CAR X)
  418.                           (MAPCAR 'RADCAN1 (CDR X))))))
  419.                 VARLIST))
  420.              (SPC0)
  421.              (FR1 (RDIS *EXP) NIL)))))
  422.  
  423. (DEFUN SPC0 ()
  424.   (PROG (*V *LOGLIST) 
  425.     (IF (ALLATOMS VARLIST) (RETURN NIL))
  426.     (SETQ VARLIST (MAPCAR (FUNCTION SPC1) VARLIST));make list of logs
  427.     (SETQ *LOGLIST (FACTORLOGS *LOGLIST))
  428.     (MAPC (FUNCTION SPC2) *LOGLIST)              ;subst log factorizations
  429.     (MAPC (FUNCTION SPC3) VARLIST GENVAR)          ;expand exponents
  430.     (MAPC (FUNCTION SPC4) VARLIST)              ;make exponent list
  431.     (DESETQ (VARLIST . GENVAR) (SPC5 *V VARLIST GENVAR))
  432.                               ;find expon dependencies
  433.     (SETQ VARLIST (MAPCAR (FUNCTION RJFSIMP) VARLIST));restore radicals
  434.     (MAPC (FUNCTION SPC7) VARLIST)))          ;simplify radicals
  435.  
  436. (DEFUN ALLATOMS (L)
  437.   (SLOOP FOR X IN L ALWAYS (ATOM X)))
  438.  
  439. (DEFUN RJFSIMP (X &AUX EXPON) 
  440.   (COND ((AND *RADSUBST $RADSUBSTFLAG) X)
  441.     ((NOT (M$EXP? (SETQ X (LET ($LOGSIMP) (RESIMPLIFY X))))) X)
  442.     ((MLOGP (SETQ EXPON (CADDR X))) (CADR EXPON))
  443.     ((NOT (AND (MTIMESP EXPON) (OR $LOGSIMP *VAR))) X)
  444.     (T (DO ((RISCHFLAG (AND *VAR (NOT $LOGSIMP) (NOT (FREEOF *VAR X))))
  445.         (POWER (CDR EXPON) (CDR POWER))) ;POWER IS A PRODUCT
  446.            ((NULL POWER) X)
  447.            (COND ((NUMBERP (CAR POWER)))
  448.              ((MLOGP (CAR POWER))
  449.               (AND RISCHFLAG (CDR POWER) (RETURN X))
  450.               (RETURN
  451.                `((MEXPT) ,(CADAR POWER)
  452.                  ,(MULN    (zl-REMOVE (CAR POWER) (CDR EXPON) 1)
  453.                     NIL))))
  454.              (RISCHFLAG (RETURN X)))))))
  455.  
  456. (DEFUN DSUBSTA (X Y ZL) 
  457.  (COND ((NULL ZL) ZL)
  458.        (T (COND ((ALIKE1 Y (CAR ZL)) (RPLACA ZL X))
  459.         ((NOT (ATOM (CAR ZL))) (DSUBSTA X Y (CDAR ZL))))
  460.       (DSUBSTA X Y (CDR ZL))
  461.       ZL)))
  462.  
  463. (DEFUN RADSUBST (A B)
  464.   (SETQ *EXP (ALLSUBST00 A B *EXP))
  465.   (IF *RADSUBST (SETQ *EXP2 (ALLSUBST00 A B *EXP2))))
  466.  
  467. (SETQ *VAR NIL)
  468.  
  469. (DEFUN SPC1 (X)
  470.   (COND ((MLOGP X) (PUTONLOGLIST X))
  471.     ((AND (MEXPTP X) (NOT (EQ (CADR X) '$%E)))
  472.      ($EXP (LIST '(MTIMES)
  473.              (CADDR X)
  474.              (PUTONLOGLIST (LIST '(%LOG SIMP RATSIMP)
  475.                      (CADR X))))))
  476.     (T X)))
  477.  
  478. (DEFUN PUTONLOGLIST (L)
  479.   (UNLESS (MEMALIKE L *LOGLIST) (PUSH L *LOGLIST))
  480.   L)
  481.  
  482. (DEFUN SPC2 (P)
  483.   (RADSUBST (RFORM (CDR P)) (RFORM (CAR P)))
  484.   (DSUBSTA (CDR P) (CAR P) VARLIST))
  485.  
  486. (DEFUN SPC2A (X)                    ;CONVERTS FACTORED
  487.        ((LAMBDA (SUM)                    ;RFORM LOGAND TO SUM 
  488.         (IF (CDR SUM) (CONS '(MPLUS) SUM)    ;OF LOGS
  489.             (CAR SUM)))
  490.     (MAPCAR (FUNCTION SPC2B) X)))
  491.      
  492. (DEFUN SPC2B (X)
  493.   (LET ((LOG `((%LOG SIMP RATSIMP IRREDUCIBLE) ,(PDIS (CAR X)))))
  494.     (IF (EQUAL 1 (CDR X)) LOG
  495.     (LIST '(MTIMES) (CDR X) LOG))))
  496.      
  497. (DEFUN SPC3 (X V &AUX Y) 
  498.   (WHEN
  499.    (AND (M$EXP? X)
  500.     (NOT (ATOM (SETQ Y (CADDR X))))
  501.     (MPLUSP (SETQ Y (EXPAND1 (IF *VAR ($PARTFRAC Y *VAR) Y)
  502.                  10 10))))
  503.    (SETQ Y (CONS '(MTIMES) (MAPCAR #'(LAMBDA (Z) ($RATSIMP ($EXP Z)))
  504.                    (CDR Y))))
  505.    (RADSUBST (RFORM Y) (RGET V))
  506.    (DSUBSTA Y X VARLIST)))
  507.  
  508. (DEFUN SPC4 (X) 
  509.   (IF (AND (M$EXP? X)
  510.        (NOT (MEMALIKE (CADDR X) *V)))
  511.       (PUSH (CADDR X) *V)))
  512.  
  513. (DEFUN RZCONTENT (R)
  514.   (LET (((C1 P) (PCONTENT (CAR R)))
  515.     ((C2 Q) (PCONTENT (CDR R))))
  516.     (IF (PMINUSP P) (SETQ P (PMINUS P) C1 (CMINUS C1)))
  517.     (CONS (CONS C1 C2) (CONS P Q))))
  518.  
  519. ;;The GCDLIST looks like (( GCM1pair occurrencepair11 occurrencepair12 ...) ...
  520. ;;(GCMnpair occurrencepairn1 occurrencepairn2 ...))
  521. ;;where GCMpairs are lists of ratforms and prefix forms for the greatest common
  522. ;;multiple of the occurrencepairs.  Each of these pairs is a list of a ratform
  523. ;;and a prefix form.  The prefix form is a pointer into the varlist.  
  524. ;;The occurrences are exponents of the base %E.
  525.  
  526. (DEFUN SPC5 (VL OLDVARLIST OLDGENVAR &AUX GCDLIST VARLIST GENVAR)
  527.   (DOLIST (V VL)
  528.       (LET* ((((NIL . C) . R) (RZCONTENT (RFORM V)))
  529.          (G (zl-ASSOC R GCDLIST)))
  530.         (COND (G (SETF (CADR G) (PLCM C (CADR G)))
  531.              (PUSH (LIST ($EXP V) C) (CDDR G)))
  532.           (T (PUSH (LIST R C (LIST ($EXP V) C)) GCDLIST)))))
  533.   (DOLIST (G GCDLIST)
  534.       (LET ((RD (RDIS (CAR G))))
  535.         (WHEN (AND (MLOGP RD) (MEMALIKE (CADR RD) OLDVARLIST))
  536.           (PUSH (LIST (CADR RD) 1) (CDDR G)))
  537.         (RPLACA G ($EXP (DIV RD (CADR G))))))
  538.   (SPC5B GCDLIST OLDVARLIST OLDGENVAR))
  539.  
  540. ;(DEFUN SPC5B (V VARLIST GENVAR) 
  541. ;  (DOLIST (L V)
  542. ;     (DOLIST (X (CDDR L))
  543. ;         (UNLESS (EQUAL (CADR L) (CADR X))
  544. ;             (RADSUBST (RATEXPT (RFORM (CAR L))
  545. ;                    (CAR (QUOTIENT (CADR X) (CADR L))))
  546. ;                      (RFORM (CAR X))))))
  547. ;  (CONS VARLIST GENVAR)) 
  548.  
  549.  
  550. (DEFUN SPC5B (V VARLIST GENVAR) 
  551.   (DOLIST (L V)
  552.      (DOLIST (X (CDDR L))
  553.          (UNLESS (EQUAL (CADR L) (CADR X))
  554.                 (RADSUBST (RATEXPT (RFORM (CAR L))
  555.                            (QUOTIENT (CADR L) (CADR X)))
  556.                       (RFORM (CAR X))))))
  557.   (CONS VARLIST GENVAR))
  558.  
  559. (DEFUN SPC7 (X)
  560.   (IF (EQ X '$%I) (SETQ X '((MEXPT) -1 ((RAT) 1 2))))
  561.   (WHEN (AND (MEXPTP X)
  562.          (RATNUMP (CADDR X)))
  563.     (LET ((RAD (RFORM X))
  564.           (RBASE (RFORM (CADR X)))
  565.           (EXPON (CADDR X)))
  566.       (RADSUBST (RATEXPT RBASE (CADR EXPON))
  567.             (RATEXPT RAD (CADDR EXPON))))))
  568.  
  569.  
  570. (defun goodform (l)             ;;bad -> good
  571.    (sloop for (exp coef) on l by 'pt-red
  572.      collect (cons exp coef)))
  573.  
  574. (defun factorlogs (l)
  575.        (prog (negl posl maxpl maxnl maxn)
  576.          (dolist (log l)
  577.              (setq log
  578.                (cons log (goodform
  579.                       (ratfact (rform (radcan1 (cadr log)))
  580.                            (function pfactor)))))
  581.              (cond ((equal (caadr log) -1) (push log negl))
  582.                (t (push log posl))))
  583.          (setq negl (flsort negl) posl (flsort posl) l (append negl posl))
  584.          (setq negl (mapcar (function cdr) negl)
  585.            posl (mapcar (function cdr) posl))
  586.        a     (setq negl (zl-DELETE '((-1 . 1)) negl))
  587.              (or negl
  588.          (return (mapc #'(lambda (x) (rplacd x (spc2a (cdr x)))) l)))
  589.          (setq maxnl (flmaxl negl)
  590.            maxn (caaar maxnl))
  591.        b     (setq maxpl (flmaxl posl))
  592.              (cond ((and maxpl (flgreat (caaar maxpl) maxn))
  593.             (setq posl (flred posl (caaar maxpl)))
  594.             (go b))
  595.            ((and maxpl
  596.              (not (equal (caaar maxpl) maxn)))
  597.             (setq maxpl nil)))
  598.          (cond ((and (flevenp maxpl) (not (flevenp maxnl)))
  599.             (mapc #'(lambda (fp) (rplaca (car fp) (pminus (caar fp)))
  600.                   (cond ((oddp (cdar fp))
  601.                      (zl-DELETE '(-1 . 1) fp)
  602.                      (setq negl (zl-DELETE fp negl))
  603.                      (and (cdr fp) (push (cdr fp) posl)))))
  604.               maxnl)
  605.             (go a))
  606.            (t (setq posl (flred posl maxn)
  607.                 negl (flred negl maxn))
  608.               (go a)))))
  609.  
  610. (defun flevenp (pl)
  611.   (sloop for l in pl never (oddp (cdar l))))
  612.  
  613. (defun flred (pl p)
  614.        (MAPL #'(lambda (x) (if (equal p (caaar x))
  615.                   (rplaca x (cdar x))))
  616.         pl)
  617.        (zl-DELETE nil pl))
  618.  
  619. (defun flmaxl (fpl)                   ;lists of fac. polys
  620.        (cond ((null fpl) nil)
  621.          (t (do ((maxl (list (car fpl))
  622.                (cond ((equal (caaar maxl) (caaar ll))
  623.                   (cons (car ll) maxl))
  624.                  ((flgreat (caaar maxl) (caaar ll)) maxl)
  625.                  (t (list (car ll)))))
  626.              (ll (cdr fpl) (cdr ll)))
  627.             ((null ll) maxl)))))
  628.  
  629. (defun flsort (fpl)
  630.   (mapc #'(lambda (x) (rplacd x (sortcar (cdr x) #'flgreat)))
  631.     fpl))
  632.  
  633. (defun nmt (p any)
  634.        (cond ((pcoefp p)
  635.           (if (or any (cminusp p)) 1 0))
  636.          (t (sloop for lp on (p-terms p) by 'pt-red
  637.               sum (nmt (cadr lp) any)))))
  638.  
  639. (defun nmterms (p)
  640.        (cond ((equal p -1) (cons 0 0))
  641.          (t (cons (nmt p nil) (nmt p t)))))
  642.  
  643. (defun flgreat (p q)
  644.        (let ((pn (nmterms p)) (qn (nmterms q)))
  645.         (cond ((> (car pn) (car qn)) t)
  646.           ((< (car pn) (car qn)) nil)
  647.           ((> (cdr pn) (cdr qn)) t)
  648.           ((< (cdr pn) (cdr qn)) nil)
  649.           (t (flgreat1 p q)))))
  650.  
  651. (defun flgreat1 (p q)
  652.        (cond ((numberp p)
  653.           (cond ((numberp q) (greaterp p q))
  654.             (t nil)))
  655.          ((numberp q) t)
  656.          ((pointergp (car p) (car q)) t)
  657.          ((pointergp (car q) (car p)) nil)
  658.          ((> (cadr p) (cadr q)) t)
  659.          ((< (cadr p) (cadr q)) nil)
  660.          (t (flgreat1 (caddr p) (caddr q)))))
  661.  
  662.  
  663. ; Undeclarations for the file:
  664. #-nil
  665. (DECLARE-TOP(NOTYPE NARGS))
  666.  
  667.